home *** CD-ROM | disk | FTP | other *** search
/ Fifty: Elektronik / FIFTY Elektronik (PS_Computer_Vertrieb).iso / ps8 / fty1017 / gepackt.exe / DISK2 / PLOTSRC.EXE / XMSSTM.PAS < prev   
Encoding:
Pascal/Delphi Source File  |  1993-11-10  |  4.0 KB  |  158 lines
  1. {$A+,G-}
  2. { Muss mit G- kompiliert werden sonst Absturz !!!! }
  3. UNIT XMSSTM;
  4.  
  5. INTERFACE
  6.  
  7. USES Objects, Xms;
  8.  
  9. TYPE
  10.   PXmsStream = ^TXmsStream;
  11.   TXmsStream = OBJECT (TStream)
  12.     Handle: Word;
  13.     Size: Longint;
  14.     Position: Longint;
  15.     MaxSize: WORD;
  16.     CONSTRUCTOR Init;
  17.     DESTRUCTOR Done; virtual;
  18.     FUNCTION TestError(ErrCode: INTEGER; Info: WORD): BOOLEAN;
  19.     FUNCTION GetPos: Longint; virtual;
  20.     FUNCTION GetSize: Longint; virtual;
  21.     PROCEDURE Read(var Buf; Count: Word); virtual;
  22.     PROCEDURE Seek(Pos: Longint); virtual;
  23.     PROCEDURE Truncate; virtual;
  24.     PROCEDURE Write(var Buf; Count: Word); virtual;
  25.   END;
  26.  
  27. IMPLEMENTATION
  28.  
  29.  
  30. CONSTRUCTOR TXmsStream.Init;
  31.   VAR ToAllocate : WORD;
  32.  
  33.   Procedure _Freehandle;
  34.   begin
  35.     Case XMS_Result of
  36.          XMSNoHandle,   { Kein Handle mehr frei      }
  37.          XMSInvHandle:; { Ungültiges Handle          }
  38.          else FreeMem(Handle);
  39.         end;
  40.   end;
  41.  
  42.   BEGIN
  43.     Position := 0;
  44.     Size := 0;
  45.     Status := stInitError;
  46.     IF (Not XMS_DriverOk) or (Xms.MaxAvail<16) or (XMS_Result <> 0)
  47.      THEN Status := stInitError
  48.      ELSE BEGIN
  49.       Handle := ReserveMem(1);
  50.       IF XMS_Result <> 0 THEN begin
  51.         ErrorInfo := INTEGER(XMS_Result);
  52.         _Freehandle;
  53.         Exit;
  54.         end ELSE Status := stOk;
  55.       ResizeMem(16,Handle);
  56.       MaxSize := 16;
  57.       If XMS_Result=XMSnotimpl then
  58.         begin
  59.           Freemem(Handle);
  60.           MaxSize:=XMS.MaxAvail;
  61.           Handle:=ReserveMem(MaxSize);
  62.         end;
  63.       IF XMS_Result <> 0 THEN begin
  64.         ErrorInfo := INTEGER(XMS_Result);
  65.         _Freehandle;
  66.         Exit;
  67.         end ELSE Status := stOk;
  68.     END;
  69.     ErrorInfo := INTEGER(XMS_Result);
  70.   END;
  71.  
  72. DESTRUCTOR TXmsStream.Done;
  73.   BEGIN
  74.     FreeMem (Handle);
  75.     TStream.Done;
  76.   END;
  77.  
  78. FUNCTION TXmsStream.GetPos: Longint;
  79.   BEGIN
  80.     GetPos := Position;
  81.   END;
  82.  
  83. FUNCTION TXmsStream.GetSize: Longint;
  84.   BEGIN
  85.     GetSize := Size;
  86.   END;
  87.  
  88. FUNCTION TXMSStream.TestError(ErrCode: INTEGER; Info: WORD): BOOLEAN;
  89.   BEGIN
  90.     TestError:=true;
  91.     If Status<>StOk then Exit;
  92.     IF XMS_Result <> 0
  93.      THEN BEGIN
  94.       Status := ErrCode;
  95.       XMS_Result:=0;
  96.       ErrorInfo := Info;
  97.      END
  98.      ELSE BEGIN
  99.       Status := stOk;
  100.       ErrorInfo := Info;
  101.       TestError:=false;
  102.     END;
  103.   END;
  104.  
  105. PROCEDURE TXmsStream.Read(var Buf; Count: Word);
  106.   BEGIN
  107.     IF TestError(stReadError, XMS_Result) THEN Exit;
  108.     IF Count = 0 THEN Exit;
  109.     MoveFromXMS(Count, Handle, Position, @Buf);
  110.     IF TestError(stReadError, XMS_Result) THEN Exit;
  111.     INC(Position, Count);
  112.     IF Size < Position THEN Size := Position;
  113.   END;
  114.  
  115. PROCEDURE TXmsStream.Seek(Pos: Longint);
  116.   BEGIN
  117.     IF (Pos <= Size) THEN Position := Pos;
  118.   END;
  119.  
  120. PROCEDURE TXmsStream.Truncate;
  121.   BEGIN
  122.     Size := Position;
  123.     (* Hier bleibt zu überlegen, ob und unter welchen Bedingungen ein        *)
  124.     (* ReAllocate durchgeführt werden soll.                                  *)
  125.   END;
  126.  
  127. PROCEDURE TXmsStream.Write(var Buf; Count: Word);
  128. Var NewMaxKB :Word;
  129.   BEGIN
  130.     IF TestError(stWriteError, XMS_Result) THEN Exit;
  131.     IF Count = 0 THEN Exit;
  132.     IF Position + ((Count+1) AND $FFFE) > LONGINT(MaxSize) * 1024 THEN
  133.     begin
  134.       NewMaxKB:=((Position + Count - 1) DIV 1024) + 1;
  135.       If NewMaxKB-MaxSize<16 then
  136.          NewMaxKB:=MaxSize+16; { um mind. 16 K vergrößern }
  137.       ResizeMem(NewMaxKB, Handle);
  138.       If (XMS_Result=XMSoutofMem) and (NewMaxKB-MaxSize>=16) then
  139.       begin
  140.         Repeat
  141.           ResizeMem(MaxSize+16,Handle);
  142.           IF TestError(stWriteError, XMS_Result) THEN Exit;
  143.           Inc(MaxSize,16);
  144.         Until (MaxSize-NewMaxKB)<16;
  145.         ResizeMem(NewMaxKB,Handle);
  146.       end;
  147.       IF TestError(stWriteError, XMS_Result) THEN Exit;
  148.       MaxSize := NewMaxKB;
  149.     END;
  150.     MoveToXMS(Count, Handle, @Buf, Position);
  151.     IF TestError(stWriteError, XMS_Result) THEN Exit;
  152.     INC(Position, Count);
  153.     IF Size < Position THEN Size := Position;
  154.   END;
  155.  
  156. END.
  157.  
  158.